perm filename MFPRS.SAI[MF,DEK]2 blob
sn#495987 filedate 1980-02-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 entry begin comment The output module of METAFONT.
C00006 00003 Routines for time of day and file information (highly system-dependent)
C00014 00004 Routines for proof mode.
C00034 00005 Routines for chr mode.
C00039 00006 Routines for fnt mode.
C00045 00007 Routines for tfx mode.
C00053 00008 Routines for Alphatype fonts
C00057 00009 internal procedure initout # get MFOUT started properly
C00061 ENDMK
C⊗;
entry; begin comment The output module of METAFONT.
(It is wise to read MFSYS and the raster formats explained in MFRAST
before going very deeply into the following code.)
Each output module is intended to handle a set of output devices and modes at some
particular installation. The following procedures are required:
initout gets the output module started initially
finishchar called when a character has been fully specified
closeout finishes the output
entersym when a symbol has become "known" in proof mode
clearchar initialize for a new character
This routine is designed for output in PRESS format at PARC. Changes to the MFOUT
module at SUAI are flagged by "PARCcomment";
comment Certain bits of the "control" variable govern output modes supported:
'1000 proof mode
'2000 chr file mode
'4000 make TEX information file
'10000 make xgp font
'20000 make Alphatype CRS font
'400000 label the points in proof mode
;
comment Certain bits of the "control" variable govern the on-line output:
'1000000 display each character after it has been fully drawn
'4000000 make arrow for illustration file in proof mode
'10000000 illustration file in proof mode to be color separated
;
require "MFHDR.SAI" source_file;
define PARCcomment = ⊂comment⊃;
internaldef symbolic=⊂(control land '1000)⊃ # keep list of "known" xy-variables;
define proofmode=⊂(control land '1000)⊃, chrmode=⊂(control land '2000)⊃,
fntmode=⊂(control land '10000)⊃, crsmode=⊂(control land '20000)⊃;
internaldef tfxmode=⊂(control land '4000)⊃;
define points=⊂(control land '400000)⊃;
define chardisplay=⊂(control land '1000000)⊃;
define arrow=⊂(control land '4000000)⊃;
define color=⊂(control land '10000000)⊃;
internaldef brksize=10 # the number of distinct breaks per character;
internal integer array brktab[0:brksize+1] # breaks in increasing order;
internal integer brkptr # current number of entries in brktab;
preload_with 0,1,2,27,3,24,28,33,4,17,25,31,29,12,34,14,5,8,18,36,26,23,32,16,
30,11,13,7,35,22,15,10,6,21,9,20,19; saf integer array bit_id[0:36];
comment Routines for time of day and file information (highly system-dependent);
comment These routines are due to Hans Moravec;
PARCcomment routines daytime and filinf changed;
integer octaltime;
string procedure daytime;
begin return(odtim(-1,-1)) end;
string procedure filinf(integer channel);
begin return(jfns(channel,0)) end;
comment openofil;
internal string maintitle # symbolic description of the font being generated;
internal string ofilname # output file name, set by first input;
string timeofday # time to be used on output;
internaldef numberofmodes=5 # number of output modes supported;
internaldef tfx=1,xgpfnt=3,proof=2,alf=5,chrs=4 # symbolic names of modes;
comment Use odd-numbered modes for files with binary output;
saf integer array ochan[1:numberofmodes] # channels for output;
saf string array ofilext[1:numberofmodes] # file name extensions;
saf string array flname[1:numberofmodes] # actual file names opened;
integer prfpno # page number in proof mode;
string prfheader # time of day and filename for proof mode;
integer greyhue, edgehue, dothue, curhue # hues in color mode;
integer fntptr # number of words output in fntmode or preamble words in crsmode;
integer alfptr # number of words output in crsmode;
internaldef initblocks=6 # max number of blocks of preamble to font files;
internal saf integer array fntdir[0:'200*initblocks-1] # first blocks of font file;
require "PRESSOUT.SAI" source_file;
integer procedure gethue(string prompt);
begin string s; integer acc;
outstr("Enter hue for "&prompt&":"); s←inchwl;
acc←0;
while (s≥"0") and (s≤"9") do acc←10*acc+lop(s)-"0";
return(acc);
end;
integer procedure openofil(integer t) # initializes output for mode t;
begin comment This procedure is called when output for mode t is requested.
It opens the file and gets things started and returns the channel number;
integer i # loop index; string fn # output file name;
if ochan[t]≥0 then return(ochan[t]);
if not ofilname then ofilname←"mfput";
fn←ofilname&ofilext[t];
PARCcomment proofmode needs 8-bit byte output (see below);
if t neq proof then begin "36-bit"
open(ochan[t]←getchan,"DSK",if t land 1 then 8 else 0,0,2,0,0,eof);
loop begin
enter(ochan[t],fn,eof);
if eof then
begin print(nextline,"I can't write on file ",fn,
nextline,"Output file = ");
fn←inchwl;
end
else done;
end;
flname[t]←fn;
end "36-bit";
case t of begin
[xgpfnt] begin string longtitle;
if ochan[alf]≥0 then errorstop("Incompatible resolution");
for i←0 thru '237 do fntdir[i]←0;
longtitle←maintitle&(nextline&"Written by METAFONT, ")&timeofday;
for i←'240 thru '377 do fntdir[i]←cvasc(longtitle[5*(i-'237)-4 for 5]);
arryout(ochan[xgpfnt],fntdir[0],'400) # will be overwritten later;
fntptr←'400; fntdir['203]←maxht end;
[chrs] out(ochan[chrs],maintitle&(nextline&"Based on .CHR file written by METAFONT, ")&
timeofday&(nextline&"⊗"&nextline)) # font description page;
[proof] begin PARCcomment open file for 8-bit byte output;
external integer !skip!;
loop begin
ochan[t]←gtjfn(fn,1);
if not !skip! then openf(ochan[t], (8 lsh byteSizeShift) + writeAccess);
if !skip! then
begin print(nextline,"I can't write on file ",fn,
nextline,"Output file = ");
fn←inchwl;
end
else done;
end;
jfn ← cvjfn(ochan[t]);
flname[t]←fn;
prfpno←0;
prfheader←timeofday&" "&filinf(ochan[proof])&" Page ";
recnum←0; outcount←0; nparts←0;
pdptr←point(16,partdir[0],-1);
greyhue←edgehue←dothue←0 # default if color turned on later;
if color then
begin greyhue←gethue("internal pixels (R=0,Y=40,G=80,C=120,B=160,M=200)");
edgehue←gethue("boundary pixels");
dothue←gethue("data points");
end;
end;
[alf] begin if ochan[xgpfnt]≥0 then errorstop("Incompatible resolution");
for i←0 thru '177 do fntdir[i]←0; fntdir['200]←octaltime;
fntdir['201]←(1365 lsh hw)+2047; fntptr←'204;
arryout(ochan[alf],fntdir[0],'200*initblocks) # will be overwritten later;
alfptr←initblocks*'200 end;
else comment do nothing;
end;
return(ochan[t]);
end;
comment Routines for proof mode.
In proof mode, all of the xy-variables are remembered in a special table
as soon as both coordinates become known. This table is organized as a
doubly threaded binary search tree, ordered by decreasing $y$ coordinate,
and for fixed $y$ by increasing $x$ coordinate (i.e., top to bottom, left to right).
The tree nodes have several fields:
llink[p] left son (if $>p$) or inorder predecessor (if $≤p$)
rlink[p] right son (if $>p$) or inorder successor (if $≤p$)
ycoord[p] $y$ coordinate of the point
xcoord[p] $x$ coordinate of the point
strng[p] symbolic name of the point (to be put into the label box)
xll[p],yll[p] coordinates of lower left corner of point label box
xur[p],yur[p] coordinates of upper right corner of point label box
prevbox[p] pointer to previous point label box, ordered by \\{yll}
Hidden points have strng[p] null.
We have $\\{rlink}[0]=0$ and \\{llink}[0] points to the root of the tree.
The smallest unused node is \\{tptr}. To set the tree empty, one sets
$\\{llink}[0]←0$ and $$\\{tptr}←1$. The fields \\{xll}, \\{yll}, \\{xur}, \\{yur},
and \\{prevbox} are used only when allocating boxes for the point labels, just
before outputting the raster pattern. Actually \\{yur} is not stored in memory,
since $\\{yur}[p]$ always equals $\\{yll}[p]+10$.
;
internaldef proofmemsize=50 # size of proof mode tables;
integer saf array llink,rlink,ycoord,xcoord,xll,yll,xur,prevbox[0:proofmemsize-1];
string saf array strng[0:proofmemsize-1];
integer tptr # end of tree;
integer bxptr # pointer to last point label box (head of the \\{prevbox} list);
internal procedure proofins(integer xco,yco; string s) # inserts into tree;
begin integer q,r # pointer variables;
label moveleft,moveright,insert # go here to move downward in the tree;
label compare # go here to decide where to move next in the tree;
r←0;
moveleft: q←llink[r]; if q≤r then
begin llink[r]←tptr; rlink[tptr]←r; llink[tptr]←q; go to insert;
end;
r←q;
compare: if yco>ycoord[r] then go to moveleft;
if yco<ycoord[r] or xco>xcoord[r] then go to moveright;
if xco<xcoord[r] then go to moveleft;
return # this point duplicates one that's already present;
moveright: q←rlink[r]; if q≤r then
begin rlink[r]←tptr; llink[tptr]←r; rlink[tptr]←q; go to insert;
end;
r←q; go to compare;
insert: ycoord[tptr]←yco; xcoord[tptr]←xco; strng[tptr]←s;
tptr←tptr+1; if tptr≥proofmemsize then overflow(proofmemsize);
end;
procedure makeproof # Outputs the raster in printable form;
begin
comment This routine figures out how to label the points, and then
it outputs the raster in a format that is printable with a special font.
The point label locations are computed in the following way: We go through
the points from top to bottom, left to right, and use the first available
position from a list of five choices:
centered above the point
centered to the left of the point
centered to the right of the point
centered below the point
in the right margin below previous entries like this
(The last case always succeeds if the other four fail.) A position is
"available" if the corresponding box containing the symbolic name of the point
does not overlap with any previously placed boxes, and if this box is at least
two units away from every other point, measuring distance along vertical
and horizontal lines (Manhattan style). (The box is one unit away from
the point it corresponds to.)
Output for the XGP server is a sequence of 7-bit character codes of the following
types:
'177&'001&'040&x1&x2, where x1&x2=x is a 14-bit binary number, x<4096
means "move to column x"
c, where c is a letter or digit or "."
means "output character c in the FIG font and advance as many
columns as c's width
'012&'177&'003&y1&y2, where y1&y2=y is a 14-bit binary number
means "move to row y (numbered from the top, increasing downwards)
'015&'014&'177&'006&'001
means "cut the paper at the current row (and select FIG font)"
;
PARCcomment procedure twobytes deleted, macros movetocol and movetorow changed, macro cutpage deleted;
define doverRes=384;
define xgptodover(x)=⊂((x) lsh cellsh+.9)*(micasPerInch/doverRes)⊃;
define movetocol(x)=⊂if rotated then SetY(xgptodover(xr-(x)+100))
else SetX(xgptodover((x)-xl+50))⊃;
define movetorow(y)=⊂if rotated then SetX(xgptodover(yhigh-(y)+50))
else SetY(xgptodover(yhigh-(y)+100))⊃;
define makehue(x)=⊂begin if curhue≠x then begin SetHue((x));
curhue←x; movetorow(cury) end end⊃;
PARCcomment in this procedure out(ch,chr) is replaced by outch(chr) and out(ch,str) by outchs(str);
PARCcomment new parameters chrinit, ptinit, controlled by cellsize;
integer chrinit, ptinit;
integer xl,xr,p,q,r,ch,y,x,state,curx,cury;
integer xwbase # position in \\{rast};
integer z,zw # current bit;
integer xbit,xbitl,xbitr;
integer zt,zr,zb,zl # bit patterns of neighbors;
integer c,mode # encoding of neighborhood;
integer yextra # coordinate for case 5 labels;
procedure clearstate # Outputs bit codes that have accumulated;
begin comment This procedure is used in the routine that puts out the raster.
If state = n > 0, we output the code for n grey cells
(where P=1 cell, Q=2, R=4, etc.), while if state = -m < 0 we output
the code for m blanks;
integer pt # power of 2;
string chr # corresponding character;
if state<0 then
begin movetorow(cury←cury-state); state←0; return end;
if color then
begin if mode=15 then makehue(greyhue) else makehue(edgehue);
end;
if state=1 then
begin outch('117 xor mode); cury←cury+1; state←0; return end;
comment Now mode = 5 + 8L + 2R;
chr←case ((mode-5) lsh -1) of ('25,'35,"U","U",'45,"U");
pt←32 # the font has only "P", "Q", "R", "S", "T", and "U";
loop begin
while state≥pt do
begin outch(chr); state←state-pt; cury←cury+pt end;
if state=0 then return;
pt←pt lsh -1; chr←chr-1;
end;
end;
PARCcomment initialize chrinit, ptinit;
comment chrinit←if cellsize=4 then "U" else "U";
comment ptinit←if cellsize=4 then 32 else 32;
xl←xleft*bitsperwd+(xrastmin+xpenmin) # leftmost bit position being output;
xr←xright*bitsperwd+(xrastmin+xpenmin+bitsperwd-1) # rightmost;
bxptr←0 # set list of active boxes empty;
yextra←yhigh;
p←0; if points then while llink[p]>p do p←llink[p] # start at topmost leftmost point;
while p do
begin integer j # choice number for the label;
integer m # four times the length of the label;
integer x0,y0,x1,y1 # coordinates of the box;
label advancep # go here when done with $p$;
if xcoord[p]<xl or xcoord[p]>xr or ycoord[p]>yhigh or ycoord[p]<ylow
or strng[p]=0
then go to advancep # points out of range won't be shown;
m←4*length(strng[p]);
for j←1 thru 5 do
begin integer q # runs through things that shouldn't clash;
label reject # go here when case $j$ is illegal;
case j of begin
[1] begin x0←xcoord[p]-1-m; y0←ycoord[p]+1 end;
[2] begin x0←xcoord[p]-3-2*m; y0←ycoord[p]-5 end;
[3] begin x0←xcoord[p]+1; y0←ycoord[p]-5 end;
[4] begin x0←xcoord[p]-1-m; y0←ycoord[p]-11 end;
else begin x0←infty; done end
end;
x1←x0+2+2*m; y1←y0+10;
q←p # first we will check points just before $p$;
loop begin integer x,y,r # temporary storage;
integer dist # Manhattan distance;
if (r←llink[q])≤q then
if r then q←r else done
else begin q←r; while (r←rlink[q])>q do q←r;
end;
comment The above lines moved $q$ backwards one;
y←ycoord[q]; if y>y1+1 then done # no clash possible;
if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
else dist←0;
x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
x≤x0 then dist←dist+x0-x;
if dist≤1 then go to reject;
end;
q←p # next we will check points just after $p$;
loop begin integer x,y,r # temporary storage;
integer dist # Manhattan distance;
if (r←rlink[q])≤q then
if r then q←r else done
else begin q←r; while (r←llink[q])>q do q←r;
end;
comment The above lines moved $q$ forwards one;
y←ycoord[q]; if y<y0-1 then done # no clash possible;
if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
else dist←0;
x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
x≤x0 then dist←dist+x0-x;
if dist≤1 then go to reject;
end;
q←bxptr # finally we check that no overlap occurs;
while q do
begin
if yll[q]>y1 then done;
if x1≥xll[q] and x0≤xur[q] and y0≤yll[q]+10
then go to reject;
q←prevbox[q];
end;
done # all tests have been passed;
reject: # this value of $j$ didn't work;
end;
if x0=infty then
begin comment case 5;
xll[p]←(xright-xleft)*bitsperwd+(bitsperwd+24);
xur[p]←xll[p]+2*m+2;
yextra←yextra-20; yll[p]←yextra;
end
else begin comment case 1, 2, 3, or 4;
xll[p]←x0; xur[p]←x1; yll[p]←y0;
end;
q←bxptr; r←0;
while q and yll[q]<yll[p] do
begin r←q; q←prevbox[q];
end;
prevbox[p]←q; if r then prevbox[r]←p else bxptr←p;
advancep:
if (r←rlink[p])≤p then p←r
else begin p←r; while (r←llink[p])>p do p←r;
end;
end;
comment Now all points have been output, so we output the raster pattern.
White spaces are handled by "skips", but grey cells are classified into
sixteen kinds according to the presence or absence of neighbors above, right,
below, or left of a cell. An ordinary cell has all four neighbors present.
Codes "A", "B", ..., "O" are used for the cases when one or more neighbors
is absent, using a binary code. The "fig" font uses this information to put
boundary lines at the edges.
The "fig" font is designed so that character "." placed at location (x,y) indicates
a big black dot centered on cell (x,y). The digits 0...9 and lower case letters
are designed to have a width of 8 cells, and so that the character will be
approximately centered in an 11x11 rectangle whose lower left corner is (x0,y0) and
whose upper right corner is (x0+10,y0+10) if the string begins at cell (x0+2,y0+8).;
comment First we relink the point label boxes into down-the-page order and increase
the \\{xll} and \\{yll} coordinates to account for the font offset;
q←0; while bxptr do
begin r←prevbox[bxptr]; prevbox[bxptr]←q; q←bxptr; bxptr←r;
xll[q]←xll[q]+2; yll[q]←yll[q]+8;
end;
bxptr←q;
ch←openofil(proof); StartPage # begin a new page of output;
if not arrow then begin
SetY(1270) # insert page number and time at XGP row 50;
SetX(1270) # beginning at XGP column 100;
newfont(0) # selecting font 0;
outchs(prfheader&cvs(prfpno←prfpno+1));
if pagewarning then outchs(" "&pagewarning);
end;
newfont(1) # then select font 1;
curhue←-1;
if color then SetBrightnessAndSaturation;
comment Now output raster;
curx←xl-1;
for x←xleft thru xright do
for xbit←-35 thru 0 do
begin
movetocol(curx←curx+1);
state←-1; cury←ylow-1;
xwbase←x*rspan;
z←0; zt←rast[xwbase+ylow] lsh xbit land 1;
xbitl←xbit-1+3; xbitr←xbit+1+1;
for y←ylow thru yhigh do
begin
define xw=⊂xwbase+y⊃;
zb←z lsh 2; z←zt;
if y≠yhigh then zt←rast[xw+1] lsh xbit land 1 else zt←0;
if z=0 then
begin if state>0 then clearstate; state←state-1 end
else
begin # bit is dark;
zw←rast[xw];
if xbit neq -35 then zl←zw lsh xbitl land 8
else if x=xleft then zl←0
else zl←rast[xw-rspan] lsh 3 land 8;
if xbit neq 0 then zr←zw lsh xbitr land 2
else if x=xright then zr←0
else zr←rast[xw+rspan] lsh -35 lsh 1;
c ← zl + zb + zr + zt;
if state<0 or c neq mode then
begin if state≠0 then clearstate; mode←c end;
state←state+1;
end;
end;
if state>0 then clearstate;
end;
if color then makehue(dothue);
while bxptr do
begin comment Outputting a point label;
movetorow(yll[bxptr]);
movetocol(xll[bxptr]);
outchs(strng[bxptr]);
bxptr←prevbox[bxptr];
end;
p←0;
if points then while llink[p]>p do p←llink[p] # go to the topmost leftmost point;
while p do
begin comment Outputting a point dot;
if ycoord[p]≤yhigh and ycoord[p]≥ylow and xcoord[p]≥xl and
xcoord[p]≤xr then
begin movetorow(ycoord[p]);
movetocol(xcoord[p]);
outch(".");
end;
if (r←rlink[p])≤p then p←r
else begin p←r; while (r←llink[p])>p do p←r;
end;
end;
PARCcomment put "arrow" at origin (for pressedit);
if arrow then begin movetorow(0); movetocol(0); newfont(0); outchs("<==<<") end;
PARCcomment output data for this character (see PRESSOUT.SAI);
finproofchar;
end;
comment Routines for chr mode.
In this mode we output the characters in asterisk-dot form. Exactly two
columns have more than one dot, these columns specifying the pixels to the
left and right of the character (columns -1 and chardw).
Exactly one row has more than two dots, this row being the baseline (row 0);
procedure makechr # outputs the current character to .chr file;
begin integer xrk,xl,xr,xw,y,yl,yh,z,lz,xlb,lkd,rkd,bsd,ch,xwr,x,bits,xx;
label nonblank1,nonblank2,nonblank3,nonblank4;
if chardw<0 then
begin chardw←0; error("Negative chardw, replaced by 0");
end
else if chardw>xrastmax+xpenmax then overflow(xrastmax+xpenmax);
xrk←rcol(chardw);
xl←xleft min rcol(-1); xr←xright max xrk;
while xl<rcol(-1) do
begin comment try to eliminate blank column at left;
xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do if rast[y] then go to nonblank1;
xl←xl+1;
end;
nonblank1: while xr>xrk do
begin comment try to eliminate blank column at right;
xw←xr*rspan;
for y←xw+ylow thru xw+yhigh do if rast[y] then go to nonblank2;
xr←xr-1;
end;
nonblank2: yl←ylow min 0; yh←yhigh max 0;
while yl<0 do
begin comment try to eliminate blank row at bottom;
for xw←xleft*rspan+yl step rspan until xright*rspan+yl do
if rast[xw] then go to nonblank3;
yl←yl+1;
end;
nonblank3: while yh>0 do
begin comment try to eliminate blank row at top;
for xw←xleft*rspan+yh step rspan until xright*rspan+yh do
if rast[xw] then go to nonblank4;
yh←yh-1;
end;
nonblank4:if xl=rcol(-1) then z←1 lsh (hw+1) else z←0; xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
lz←0; while z>0 do
begin lz←lz+1; z←z lsh 1;
end;
xlb←1-hw+lz+bitsperwd*(xl-rcol(0));
ch←openofil(chrs);
out(ch,'14&"'"&cvos(charcode)&nextline);
y←yh; lkd←rkd←bsd←0;
while y≥yl or lkd≤1 or rkd≤1 do
begin label rowdone;
xw←xl*rspan+y; xwr←xr*rspan+y;
x←xlb; z←rast[xw] lsh lz; bits←bitsperwd-lz;
loop begin if bits=0 then
begin bits←bitsperwd; xw←xw+rspan; z←rast[xw];
end;
if z<0 then out(ch,"*")
else if x=-1 then
begin out(ch,"."); lkd←lkd+1;
end
else if x=chardw then
begin out(ch,"."); rkd←rkd+1;
end
else if y=0 then
begin label nonblank;
if z=0 and x>chardw and bsd>2 then
begin for xx←xw+rspan step rspan until xwr do
if rast[xx] then go to nonblank;
go to rowdone;
end;
nonblank: out(ch,"."); bsd←bsd+1;
end
else begin label nonblank;
if z=0 and x>chardw then
begin for xx←xw+rspan step rspan until xwr do
if rast[xx] then go to nonblank;
go to rowdone;
end;
nonblank: out(ch," ");
end;
z←z lsh 1; bits←bits-1; x←x+1;
end;
rowdone: out(ch,nextline); y←y-1;
end;
end;
comment Routines for fnt mode.
In this mode we output the characters in binary format as required by the
XGP conventions documented in "Find a Font" by Les Earnest,
SAIL Operating Note 74, May 1976, as subsequently modified to allow negative
left kerns and to pack data according to raster_width instead of character_width;
define ytop=⊂fntdir['203]⊃, maxwdth=⊂fntdir['202]⊃, maxdpth=⊂fntdir['201]⊃;
procedure makefnt # outputs the current character to .fnt file;
begin integer xl,xr,z,xw,y,lz,xlb,xrb,lzr,yl,yh,ch,xlw,lz1,xrw;
integer rasterwidth,datarowcount,rowsfromtop,leftkern,wordcount;
label nonblank3,nonblank4,outchar;
ch←openofil(xgpfnt);
if chardw<0 then
begin chardw←0; error("Negative chardw, replaced by 0");
end;
xl←xleft; xr←xright; z←0;
loop begin comment try to eliminate blank column at left;
xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
if z then done;
xl←xl+1;
if xl>xr then
begin comment blank raster;
rasterwidth←rowsfromtop←datarowcount←leftkern←wordcount←0;
go to outchar;
end;
end;
lz←0; while z>0 do
begin lz←lz+1; z←z lsh 1;
end;
xlb←(1-hw-bitsperwd*rcol(0))+lz+bitsperwd*xl;
z←0;
while xr>xl do
begin comment try to eliminate blank column at right;
xw←xr*rspan;
for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
if z then done;
xr←xr-1;
end;
lzr←(bitsperwd-1)-bit_id[((z land(-z))lsh -1) mod 37];
xrb←(1-hw-bitsperwd*rcol(0))+lzr+bitsperwd*xr;
yl←ylow; yh←yhigh;
loop begin comment try to eliminate blank row at bottom;
for xw←xl*rspan+yl step rspan until xr*rspan+yl do
if rast[xw] then go to nonblank3;
yl←yl+1;
end;
nonblank3:
loop begin comment try to eliminate blank row at top;
for xw←xl*rspan+yh step rspan until xr*rspan+yh do
if rast[xw] then go to nonblank4;
yh←yh-1;
end;
nonblank4: if yh>ytop then
begin error("Character '"&cvos(charcode)&" goes over the top ("&
cvs(yh)&" > "&cvs(ytop)&")");
yh←ytop;
end;
if chardw<xlb then
begin lz←(lz+xlb-chardw) mod bitsperwd; xlb←chardw; xl←rcol(chardw);
end;
maxwdth←maxwdth max chardw;
maxdpth←maxdpth min yl;
rasterwidth←xrb-xlb+1;
datarowcount←yh-yl+1;
wordcount←if rasterwidth>hw then ((rasterwidth-1) div bitsperwd + 1)*datarowcount
else (datarowcount-1) div (bitsperwd div rasterwidth) + 1;
leftkern←-xlb;
rowsfromtop←ytop-yh;
outchar:
if fntdir[charcode] then error("Duplicate charcode: '"&cvos(charcode));
fntdir[charcode]←(chardw lsh hw)+fntptr;
comment The next two lines assume that bitsperwd=36;
wordout(ch,(rasterwidth lsh 27)+(charcode lsh 18)+wordcount+2);
wordout(ch,(leftkern lsh 27)+(rowsfromtop lsh 18)+datarowcount);
fntptr←fntptr+2+wordcount;
if rasterwidth=0 then return;
xlw←xl*rspan; lz1←lz-bitsperwd;
if rasterwidth≤hw then
begin integer bits,accum;
bits←accum←0;
for y←xlw+yh step -1 until xlw+yl do
begin z←(rast[y] lsh lz)+(rast[y+rspan] lsh lz1);
accum ← accum lor (z lsh (-bits));
bits←bits+rasterwidth;
if bits+rasterwidth>bitsperwd then
begin wordout(ch,accum);
bits←accum←0;
end;
end;
if bits then wordout(ch,accum);
end
else begin xrw←xr*rspan; if lz>lzr then xrw←xrw-rspan;
for y←yh step -1 until yl do for xw←y+xlw step rspan until y+xrw do
wordout(ch,(rast[xw]lsh lz)+(rast[xw+rspan]lsh lz1));
end;
end;
comment Routines for tfx mode.
This mode is a rather tedious set of routines that pack information into the
format TEX wants;
integer nwd,nht,ndp,ndw,nic;
internal integer nkr,nlg # table pointers in tfx mode;
internal saf integer array tfxdir[0:'177] # tfx mode character table;
internaldef wds=6,hts=4,dps=4,ics=6,dws=6,lgs=9 # sizes of tfx fields;
define wdmsk=(1 lsh wds)-1,htmsk=(1 lsh hts)-1,dpmsk=(1 lsh dps)-1,
icmsk=(1 lsh ics)-1,dwmsk=(1 lsh dws)-1;
internaldef lgmsk=(1 lsh lgs)-1 # maximum ligature field;
internaldef lgd=wds+hts+dps+ics+dws # ligature displacement;
saf real array tfxwd[0:wdmsk+1] # tfx width table;
saf real array tfxht[0:htmsk+1] # tfx height table;
saf real array tfxdp[0:dpmsk+1] # tfx depth table;
saf integer array tfxic[0:icmsk+1] # tfx italic-correction (and misc) table;
saf integer array tfxdw[0:dwmsk+1] # tfx device-width table;
internal saf integer array tfxlg[1:lgmsk+'177] # tfx ligature-and-kern codes;
internal saf real array tfxkr[0:lgmsk+'177] # tfx kern values;
internaldef tfxparsize=24 # max number of tfx parameters;
internal saf real array tfxpars[1:tfxparsize] # tfx parameters;
internal integer tfxptr # number of tfx parameters stored;
preload_with true; saf boolean array tfxnot[0:0] # tfx mode initialized;
internal procedure tfxinit # ensures that tfx tables have been initialized;
if tfxnot[0] then
begin integer ch,i; ch←openofil(tfx);
for i←0 thru '177 do tfxdir[i]←0; nwd←nht←ndp←ndw←nkr←-1;
nic←nlg←0; tfxic[0]←0 # zero ital correction is same as no ital correction;
tfxptr←0;
tfxnot[0]←false;
end;
procedure maketfx # enters tfx information for current character;
begin integer jwd,jht,jdp,jic,jdw,intic;
tfxinit;
tfxwd[nwd+1]←charwd; jwd←0; while tfxwd[jwd]≠charwd do jwd←jwd+1;
if jwd>nwd then if nwd<wdmsk then nwd←jwd else
begin real diff; integer k; diff←abs(tfxwd[0]-charwd); jwd←0;
for k←1 thru wdmsk do
begin real delta; delta←abs(tfxwd[k]-charwd);
if delta<diff then
begin diff←delta; jwd←k;
end;
end;
error("Rounding of charwd necessary, "&cvf(charwd)&" → "&cvf(tfxwd[jwd]));
end;
tfxht[nht+1]←charht; jht←0; while tfxht[jht]≠charht do jht←jht+1;
if jht>nht then if nht<htmsk then nht←jht else
begin real diff; integer k; diff←abs(tfxht[0]-charht); jht←0;
for k←1 thru htmsk do
begin real delta; delta←abs(tfxht[k]-charht);
if delta<diff then
begin diff←delta; jht←k;
end;
end;
error("Rounding of charht necessary, "&cvf(charht)&"→"&cvf(tfxht[jht]));
end;
tfxdp[ndp+1]←chardp; jdp←0; while tfxdp[jdp]≠chardp do jdp←jdp+1;
if jdp>ndp then if ndp<dpmsk then ndp←jdp else
begin real diff; integer k; diff←abs(tfxdp[0]-chardp); jdp←0;
for k←1 thru dpmsk do
begin real delta; delta←abs(tfxdp[k]-chardp);
if delta<diff then
begin diff←delta; jdp←k;
end;
end;
error("Rounding of chardp necessary, "&cvf(chardp)&"→"&cvf(tfxdp[jdp]));
end;
tfxdw[ndw+1]←chardw; jdw←0; while tfxdw[jdw]≠chardw do jdw←jdw+1;
if jdw>ndw then if ndw<dwmsk then ndw←jdw else
begin error("Too many different chardw values");jdw←ndw;
end;
intic←memory[location(charic),integer];
tfxic[nic+1]←intic; jic←0; while tfxic[jic]≠intic do jic←jic+1;
if jic>nic then if nic<icmsk then nic←jic else
begin error("Too many different charic/varchar values");jic←nic;
end;
tfxdir[charcode]←((((((((((tfxdir[charcode] lsh -lgd) lsh dws) + jdw) lsh ics)
+ jic) lsh dps) + jdp) lsh hts) + jht) lsh wds) + jwd;
end;
procedure tfxout # this procedure writes out the accumulated TEX information;
begin integer ch,j,micasize;
string s;
while tfxptr<7 do tfxpars[tfxptr←tfxptr+1]←0;
ch←openofil(tfx);
PARCcomment wordout(ch,tfxptr+(128+6+5+2)+nht+nwd+ndp+nic+nlg+nkr+ndw);
wordout(ch,tfxptr+(128+5+4+2)+nht+nwd+ndp+nic+nlg+nkr);
arryout(ch,tfxdir[0],128);
wordout(ch,nwd+1);
wordout(ch,nht+1);
wordout(ch,ndp+1);
wordout(ch,nlg+nkr+1);
wordout(ch,nic);
PARCcomment wordout(ch,ndw+1);
arryout(ch,tfxwd[0],nwd+1);
arryout(ch,tfxht[0],nht+1);
arryout(ch,tfxdp[0],ndp+1);
for j←1 thru nlg do if tfxlg[j] land (all_ones lsh -1)≥'200 lsh hw
then tfxlg[j]←tfxlg[j]+((nlg-j) lsh hw);
if nlg>0 and tfxlg[nlg]≥0 then
begin error("Ligature/kern table didn't end");
tfxlg[nlg]←tfxlg[nlg] lor (1 lsh (bitsperwd-1));
end;
arryout(ch,tfxlg[1],nlg);
arryout(ch,tfxkr[0],nkr+1);
arryout(ch,tfxic[1],nic);
PARCcomment arryout(ch,tfxdw[0],ndw+1);
arryout(ch,tfxpars[1],6);
PARCcomment wordout(ch,maxht);
PARCcomment wordout(ch,octaltime);
micasize←intscan(s←ofilname,0)*2540/72+.5;
wordout(ch,micasize) # face, micasize;
wordout(ch,memory[location(1.1),integer]) # rfudge;
arryout(ch,tfxpars[7],tfxptr-6);
end;
comment Routines for Alphatype fonts;
integer offset # character to be shifted up this amount by typesetting routine;
integer alfch # channel being used for crsmode;
PARCcomment the following replaces `require "alfout.sai[alf,dek]" source_file';
procedure clean;; procedure boundarize;; procedure crscode;;
procedure alfout # outputs portion of character in crsmode;
begin comment ylow and yhigh are multiples of 3, and we will output
rows ylow thru yhigh-1 inclusive;
if yhigh-ylow≥1024 then
begin error("Character too tall");
yhigh←yhigh min (1023-369); ylow←ylow max (-369);
end;
if yhigh>1023-369 then offset←yhigh-(1023-369)
else if ylow≤-369 then offset←ylow+369
else offset←0;
clean; boundarize; crscode;
end;
procedure makealf # outputs the current character to .ant file;
begin integer j,yl,yh;
yl←ylow; yh←yhigh;
alfch←openofil(alf);
if fntdir[charcode] then error("Duplicate charcode: '"&cvos(charcode));
j←brkptr; while j>0 do
begin if brktab[j]≤ylow+6 or brktab[j]≥yhigh-6 then
begin integer k;
k←j; while k<brkptr do
begin brktab[k]←brktab[k+1]; k←k+1;
end;
brkptr←brkptr-1;
end;
j←j-1;
end;
fntdir[charcode]←((brkptr+1) lsh hw)+fntptr;
brktab[0]←3*(((ylow+30000) div 3)-10000);
brktab[brkptr+1]←3*(((yhigh+30003) div 3)-10000);
comment the entries of brktab are all multiples of 3;
for j←0 thru brkptr do
begin ylow←brktab[j]; yhigh←brktab[j+1];
alfout;
end;
ylow←yl; yhigh←yh;
end;
internal procedure initout # get MFOUT started properly;
begin integer i # runs from 1 to numberofmodes;
maintitle←ofilname←null;
for i←1 thru numberofmodes do ochan[i]←-1;
PARCcomment ofilext[tfx], ofilext[proof] changed;
ofilext[tfx]←".tfp"; ofilext[xgpfnt]←".fnt"; ofilext[proof]←".press";
ofilext[alf]←".ant"; ofilext[chrs]←".chr";
PARCcomment octaltime←call(0,"ACCTIM");
octaltime←gtad;
timeofday←daytime;
tptr←1; llink[0]←rlink[0]←0;
cellsize←4; cellsh←2;
rotated←false;
end;
internal procedure charclear # initializes parameters for a new character;
begin charwd←chardp←charht←charic←0.0;
chardw←0; charcode←-1;
brkptr←0; brktab[0]←1 lsh (bitsperwd-1);
end;
internal procedure finishchar # outputs a finished character;
begin if chardisplay then ddoutrast;
if charcode≥0 and charcode<'200 then
begin if xleft=infty then
begin comment blank character;
xleft←xright←rcol(0); yhigh←ylow←0;
end;
if chrmode then makechr;
if proofmode then makeproof;
if tfxmode then maketfx;
if fntmode then makefnt;
if crsmode then makealf;
clearrast;
end
else if xleft<infty then
begin if proofmode then makeproof else
error("Image lost since charcode not specified");
clearrast;
end;
llink[0]←0; tptr←1 # clear the symbol table;
end;
internal procedure closeout # finishes off the output;
begin
if ochan[chrs]≥0 then
begin release(ochan[chrs]);
print(nextline,"Characters for editing written on file ",flname[chrs]);
end;
if ochan[alf]≥0 then
begin useto(alfch,1) # reposition font file at its beginning;
arryout(alfch,fntdir[0],'200*initblocks) # write the directories;
release(alfch);
print(nextline,"Images written on ",flname[alf]);
end;
if ochan[xgpfnt]≥0 then
begin useto(ochan[xgpfnt],1) # reposition font file at its beginning;
fntdir['203]←fntdir['203]+1 # this seems to work;
fntdir['201]←fntdir['203]-fntdir['201] # max(rowsfromtop+datarowcount);
arryout(ochan[xgpfnt],fntdir[0],'400) # write the font directory;
release(ochan[xgpfnt]);
print(nextline,"Images written on ",flname[xgpfnt]);
end;
if ochan[tfx]≥0 then
begin tfxout;
release(ochan[tfx]);
print(nextline,"TEX information written on ",flname[tfx]);
end;
PARCcomment proofcloseout added (see pressout.sai);
if ochan[proof]≥0 then
begin proofcloseout;
release(ochan[proof]);
print(nextline,"Proof figures written on file ",flname[proof]);
end;
end;
end